perm filename PPSRT.F4[MSS,LCS]5 blob
sn#130137 filedate 1974-11-11 generic text, type T, neo UTF8
00100 C SUBRS. RHORZ, SLUR, LOOP, PLTSRT, LINES, RDRAW
00200
05800 FUNCTION RHORZ(R)
05900 RHORZ=R*5.96-596.
06000 END
06200
06210 SUBROUTINE SLUR
06222 IMPLICIT INTEGER(A-Q,T-Z)
06234 REAL CENTR,PWDS
06258 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/PLTR/PLT,RHT,DIS
06270 COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(8),RSTJC
06282 COMMON/ALF/QQ(3),RA,R,K,KQ,TWICE,RST7,RX,RXX,RTILT,RB,
06300 1 RZ,RW,INP(57)
06314 EQUIVALENCE (RJG,RJQ(5)),(RJF,RJQ(4)),(JG,JQ(5)),
06328 1(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
06342 1,(JF,JQ(4)),(RJD,RJQ(2)),(RJE,RJQ(3))
06356 DIMENSION SLURX(53),SLURY(53),RSEQ(26)
06370 DATA RSEQ/70.0,64.0,59.0,53.9,49.0,44.1,40.0,35.8,32.0,28.2,
06384 1 25.0,21.8,19.0,16.3,14.0,11.9,10.0,8.4,6.8,5.3
07400 1 ,4.0,2.9,2.0,1.4,1.0,.07/,RWID/.2/
07600 IF(JA.NE.12)GO TO 2
07700 RA=5.96*RSTJC*RJE
07800 L=3
07900 IF(JG.LE.JF)JG=JG+360
08000 JH=6
08100 IF(PLT)JH=1
08200 DO 3 K=JF,JG,JH
08300 R=K
08400 CALL LINES(RJB+RA*SIND(R),CENTR+RA*COSD(R),L)
08500 3 L=2
08600 C JA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2
08700 RETURN
08800 2 JJ=1
08900 21 TWICE=0
09000 22 RST7=RSTJC*7.
09100 GO TO (5,6,7),JH+4
09200 GO TO 4
09300 5 R=32
09400 C AFTER DOTTED NOTE
09500 GO TO 8
09600 6 R=22
09700 C BETWEEN NOTES
09800 8 RX=-1.3
09900 GO TO 9
10000 7 R=7
10100 RX=RSTJC
10200 9 CALL RJBX(R)
10300 RJF=RJF+RX
10400 4 RXX=RHORZ(RJF)-RJB
10500 RTILT=(RJE-RJD)*RST7
10600 80 RX=SQRT(RXX**2+RTILT**2)
10700 1 R=CENTR
10800 IF(JH.GT.0)GO TO 180
10900 C FOR BRACKETS
11000 RB=RX/52.
11100 DO 81 K=1,53
11200 81 SLURX(K)=RB*(K-1)+RJB
11300 RA=-RJG*RST7
11400 R=R-RA
11500 RW=630.
11600 RB=RA/RW
11700 DO 82 K=1,26
11800 SLURY(K)=RW*RB+R
11900 SLURY(54-K)=SLURY(K)
12000 82 RW=RW-RSEQ(K)
12100 SLURY(27)=SLURY(26)
12200 L=53
12300
12400 89 IF(RTILT.EQ.0)GO TO 87
12500 RW=ATAN2(RTILT,RXX)
12600 RA=SIN(RW)
12700 RB=COS(RW)
12800 RZ=SLURX(1)
12900 RW=SLURY(1)
13000 DO 84 K=1,L
13100 SLURX(K)=SLURX(K)-RZ
13200 84 SLURY(K)=SLURY(K)-RW
13300 DO 83 K=1,L
13400 R=SLURX(K)
13500 SLURX(K)=RB*R-RA*SLURY(K)+RZ
13600 83 SLURY(K)=RB*SLURY(K)+RA*R+RW
13700
13800 87 CALL LINES(SLURX(JJ),SLURY(JJ),3)
13900 DO 88 K=JJ+1,L
14000 88 CALL LINES(SLURX(K),SLURY(K),2)
14100 IF(TWICE.OR.PLT.GE.0)RETURN
14200 TWICE=-1
14300 RJG=RJG+RWID
14400 GO TO 1
14500 RETURN
14600 180 RW=R+RJG*RST7
14700 RX=RX+RJB
14800 RA=(RJE-RJD)*RST7
14900 SLURX(1)=RJB
15000 SLURY(1)=R
15100 SLURX(2)=RJB
15200 SLURY(2)=RW
15300 SLURX(3)=RX
15400 SLURY(3)=RW+RA
15500 SLURX(4)=RX
15600 SLURY(4)=R+RA
15700 L=4
15800 IF(JH.EQ.2)L=3
15900 IF(JH.EQ.3)JJ=2
16000 TWICE=-1
16100 GO TO 87
16200 END
16300 C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
16400 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
16500
16600
17400 SUBROUTINE PLTSRT
17500 C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
17600 IMPLICIT INTEGER(S-Z)
17700 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
17800 DIMENSION P(250)
17900 DO 4 K=1,ITEM
18000 L=PWDS(K)
18100 A=RN(L+2)
18200 P(K)=A+1000*RN(L+3)
18300 4 IF(A.LT.0.OR.RN(L+1).EQ.16.)P(K)=-10000
18400 C PLOTS ALL NEG. POSITIONS FIRST.
18425 IX=I
18450 IF(I.LT.1500)I=1500
18500 Y=I
18537 I=I+IX-1
18556 IX=Y
18565 C IX IS M IN MAIN PROG.
18575 C LEAVES 1500 WDS IN RN FOR STORING "NOIR" DATA.
18600 2 A=P(1)
18700 L=1
18800 DO 1 K=1,ITEM
18900 IF(A.LE.P(K))GO TO 1
19000 A=P(K)
19100 L=K
19200 1 CONTINUE
19300 IF(A.EQ.10000.)RETURN
19400 C ALL ITEMS HAVE NOW BEEN SHUFFLED
19500 V=PWDS(L)
19600 P(L)=10000
19700 L=RN(V)+2
19800 CC CALL LOOP(0,L,1,Y,V,RN)
19810 DO 3 K=0,L
19820 3 RN(K+Y)=RN(K+V)
19830 C REPLACES SUBROUTINE LOOP
19900 Y=Y+L+1
20000 GO TO 2
20100 END
20200
20300
20400 SUBROUTINE LINES(A,B,L)
20500 COMMON /FL/IC,NZ,NX,RZ,XGP
20600 COMMON/DL/IIII,SAVER,AA /PLTR/IPLT,RHT,DIS
20700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
20800 COMMON/DPY/GO,TOP,BOT
20900 DATA BB/260.0/,CC/3.5/,DD/1.43/,MX/512/
21000 C SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
21100 CX22 GO TO 23
21200 C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
21300 CX24 AA=CC-DD*ABS(A)/BB
21400 C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
21500 CX B=B*AA
21600 23 IF(IPLT)GO TO 2
21900 CC3 IF(JA.EQ.44)GO TO 6
22000 CC K=B
22100 CC IF(K.GT.ITOP)ITOP=B
22200 CC IF(K.LT.IBOT)IBOT=B
22220 IF(B.GT.TOP)TOP=B
22240 IF(B.LT.BOT)BOT=B
22300 6 RETURN
22400 CC2 IF(IPLT.EQ.-2)RETURN
22500 C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
22600 CC IF(IXRX.EQ.0)GO TO 9
22700 CC M=ROFF(RXGP-B*RHT)
22800 CC N=ROFF(XGP+A*DIS)
22900 CC GO TO 8
23000 2 M=ROFF(A*DIS)
23100 N=ROFF(B*RHT)
23200 8 CALL PLOT(M,N,L)
23300 END
23400
23500 SUBROUTINE RDRAW(I,S,XY,X,RJB,CENTR,RMINI)
23600 C TO X,Y INTO ONE WORD
23700 DIMENSION XY(1)
23800 DO 2 K=I,IFIX(S)
23900 L=2
24000 Y=XY(K)
24100 IF(Y.LT.1000.)GO TO 3
24200 L=3
24300 Y=Y-1000.
24400 C >1000 = INVIS. LINE
24500 3 M=Y
24600 Y=(Y-M)*1000.
24700 IF(Y.GT.100.)Y=100-Y
24800 C Y NUMBERS .GT.100 ARE NEG.
24900 B=Y*X+CENTR
25000 IF(M.GT.60)M=100-M
25100 A=M*RMINI+RJB
25200 2 CALL LINES(A,B,L)
25300 END
25400
25500 FUNCTION IABS(N)
25600 IABS=N
25700 IF(N)IABS=-N
25800 END
25900
26000 BLOCK DATA
26100 IMPLICIT INTEGER(A-Q,S-Z)
26300 COMMON /NU/NUMQ(44),RNUMS(327),RACCI(22),NACCI(3)
26400 DATA
26800 1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
26900 1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
27000 1,250,256,261,266, 271,282,285,293,298,307,316,321/
27100 DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
27200 1 104.015, 107.01,107.102, 104.107, 3.107,
27300 1 14.0, 1107.011, 103.015, 103.107, 22.0,
27398 1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
27496 1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
27594 1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
27692 1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
27790 1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
27888 1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
27986 1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
28084 1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
28182 1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
28280 1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
28378 1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
28476 1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
28574 1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
28672 1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
28770 1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
28868 C THE NEXT IS FOR 'F' TO 'P'
28966 C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
29064 DATA (RNUMS(K),K=132,199)/
29162 1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
29260 1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
29358 1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
29456 1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1106.107, 0.107,
29554 1 1103.107, 103.015, 1106.015, 0.015,
29652 1 170.0, 1110.102, 110.105, 108.107, 103.107, 101.105, 101.015,
29750 1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
29848 1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 1.004,
29946 1 8.015, 8.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
30044 1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
30142 C 'Q' TO ')'
30240 DATA(RNUMS(K),K=200,327)/
30338 1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
30436 1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
30534 1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
30632 1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
30730 1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
30828 1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
30926 1 1106.015, 0.107, 6.015, 255.0, 1106.015, 103.107, 1.005, 5.107,
31024 1 8.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
31122 1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
31220 1 281.0, 1105.102, 105.105,103.105,104.102,104.105,105.102,103.102,
31318 1103.108, 106.112, 1106.112, 284., 1110.004, 2.004, 292., 1105.102,
31416 1 105.105,104.102,104.105,103.102,103.105,105.102,297.0,1110.008,
31514 1 2.008, 1110.001, 2.001, 306.0, 1101.015, 103.013, 105.010,
31612 1 106.006,106.002,105.102,103.105,101.107,315.0,1107.015,105.013,
31710 1103.01 ,102.006,102.002,103.102,105.105,107.107,320.0,1110.004,
31808 1 2.004, 1104.01, 104.102, 327.0,1110.004, 2.004, 1101.009,
31906 1 107.101, 1101.101, 107.009/
32004 C 3RD ITEM IN 19400 NOT NEEDED 12/73
32102
32200 C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
32298 DATA RACCI/6.0,1115.003, 110.007, 106.001,
32396 1 115.109, 115.021, 15.0, 1104.104, 118.108,
32494 1 1108.113, 108.016, 1104.008, 118.004,
32592 1 1114.014, 114.115, 22.0,1106.117, 106.007, 114.004
32690 1, 1114.018, 114.107, 106.104/
32788 1 ,NACCI/1,7,16/
32886 END
33000
33100 C ******* 7, POS, STF, NUM OF SHARPS OR FLATS (+ OR -), CLEF, HGT
33200 C ( CLEF = TREB,0 BASS,1 ALT,2 TEN,3 )
33300 SUBROUTINE KSIG
33400 C FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
33500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(17),T,S,Z /STF/RSTFAC(8),RSTJC
33566 EQUIVALENCE (RJD,RJQ(2)),(JD,JQ(2)),(JE,JQ(3)),(JF,JQ(4))
33632
33700
33800 JA=6
33900 C USES THIS KEY NUM IN NOTWRT
34000 KN=0
34100 C COUNTER
34200 IZ=IABS(JD)
34300 C NUMBER OF CALLS ON NOTWRT
34400 C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
34500 JW=1
34600 IF(JD.GT.0)JW=2
34700 C THE CODE FOR FLAT OR SHARP
34800 5333 CLEF=-(JE+1)
34900 C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
35000 C CLEF NOW SET IN MAIN PROG.
35100 C IF NO CLEF GIVEN, TREBLE IS USED.
35200 T=10.
35300 IF(CLEF.LT.-2.)T=11.
35400 S=CLEF+4.
35500 IF(CLEF.EQ.-4)S=-1.
35600 IF(JD.LT.0)GO TO 253
35700 W=-3.
35800 YY=4.
35900 Z=11.
36000 C SHARPS
36100 GO TO 353
36200 253 W=3.
36300 YY=-4.
36400 Z=7.
36500 C FLATS
36600 353 N=1
36700 RX=JB
36800 RA=0
36900 C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
37000 DO 553 KA=1,IZ
37100 JE=JW
37200 JB=RX+RA
37300 RA=RA+13.*RSTJC
37400 C MOVES OVER FOR NEXT ACCI.
37500 RD=Z
37600 RJD=Z
37700 IF(CLEF.NE.-1.)GO TO 7
37800 IF(RJD.GT.12.)RJD=RJD-7.
37900 GO TO 9
38000 7 RJD=RJD-S
38100 IF(RJD.GT.T)RJD=RJD-7.
38200 C ABOVE ARRANGES VERT. POS OF ACCIS.
38300 9 JD=RJD
38400 CALL NOTWRT
38500 Z=RD+W
38600 IF(N)Z=RD+YY
38700 553 N=-N
38800 END
38810
38900 C************** NOIR, NUMB ***************
38991 SUBROUTINE NOIR(RMINI)
39082 C BLACKS IN NOTES
39264 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(12),B,C,KC,D,N,JY,M,L
39355 COMMON/PLTR/IPLT,RHT,DIS /XRN/IRN(4000)
39537 EQUIVALENCE (PRE,IRN(1))
39719 DATA BL/7.4/,BH/6.5/
39810 C ADJUST BH AND FL FOR HEIGHT OF NOTE AND 'WIDTH'
39901 IPOS=ROFF(RJB*DIS)
39992 JPOS=ROFF(CENTR*RHT)
40083 IF(-RMINI.EQ.PRE)GO TO 10
40174 PRE=-RMINI
40720 D=.25*RMINI
40811 B=BH*RMINI*RHT
40902 A=BL*RMINI*DIS
40993 IC=A
41084 A=A*A
41266 E=-B/4.
41357 K=B
41448 B=B*B
41539 C USES EQUATION FOR ELLIPSE
41630 N=1
42176 NX=2
42267 6 DO 1 J=-K,K
42358 Y=J*J
42540 X=SQRT(A-(A*Y)/B)
42631 L=E-X
42722 M=X+E
42813 C THE TWO SIDES OF THE LINE
42904 IF(N)CALL EXCH(L,M)
43177 IRN(NX)=L
43268 IRN(NX+1)=M
43359 C C IS VERTICLE POS.
43450 NX=NX+2
43541 E=E+D
43632 C E IS TO TILT IT.
43723 1 N=-N
43814 10 CALL PLOT(IPOS,JPOS,3)
43905 N=2
43996 C 1ST LOC. OF ARRAY HAS "PRE"
44087 L=IPOS+IC
44178 DO 11 M=-K,K
44269 J=M+JPOS
44360 CALL PLOT(L+IRN(N),J,2)
44451 CALL PLOT(L+IRN(N+1),J,2)
44542 11 N=N+2
44633 END
44760
45100 SUBROUTINE DRWNT(RMINI)
45200 COMMON /STF/RSTFAC(8),RSTJC
45300 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
45400 EQUIVALENCE (JE,JQ(3)),(RJD,RJQ(2)),(RJF,RJQ(4)),
45500 1 (JG,JQ(5)),(RJG,RJQ(5)),(RJE,RJQ(3)),(RJZ,RJQ(20))
45600 1 ,(JI,JQ(7)),(RJI,RJQ(7)),(JH,JQ(6))
45700 RJX=CENTR
45800 JH=0
45900 C JH=0 SO IT WILL FILL. (P8 IN 'CLEFS')
46100 RA=RJF
46200 RJF=.5*RMINI/RSTJC
46300 RJG=RJF
46400 RJD=RJZ-3
46600 C ADJUSTS POSITION FOR MINI ACCIDENTALS (..??!!)
46700 JI=0
46800 CALL CLEFS
46900 JI=RJI
47000 C ↑↑↑↑↑↑ NEEDED??
47100 C FIX THIS???? ↑↑↑↑↑
47200 C FOR WHITE NOTES AND ACCIS ON PLOTTER.
47300 CENTR=RJX
47400 RJF=RA
47500 RJG=JG
47600 JE=RJE
47700 END